home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 626-637 / disk_635 / powerlogo / utilities < prev    next >
Text File  |  1992-05-06  |  14KB  |  480 lines
  1.  
  2. ;  Utilities
  3.  
  4. pr [ ]
  5. pr [ This file adds menus to the LOGO user interface, ]
  6. pr [ and defines some useful procedures and constants. ]
  7. pr [ ]
  8.  
  9. ; *** Set amount of memory reserved by LOGO.
  10. ( system 2 * 15 8192 )
  11.  
  12. ; *** Scramble random number generater.
  13. ( seedrand * 100 seconds )
  14.  
  15. ; *** Has this file already been loaded?
  16. if buriedp "utility-stuff [ unbury :utility-stuff ] [ ]
  17.  
  18. ; *** Numerical constants.
  19. make "e  2.71828182845904523536
  20. make "pi 3.14159265358979323846
  21.  
  22. ; *** Output list of all variable names.
  23. make "all [ procedure [ ] output se namelist burylist ] 
  24.  
  25. ; *** Output list of names that contain something other than procedures.
  26. make "allnames [ 
  27.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  28.    make "scr-n se burylist namelist 
  29.    dowhile 
  30.    [  make "scr-x first :scr-n 
  31.       make "scr-n bf :scr-n 
  32.       if (  or primitivep :scr-x 
  33.             procedurep :scr-x 
  34.             if > 4 count :scr-x 
  35.             [  false ] 
  36.             [  = "scr- items 1 4 :scr-x ] ) 
  37.       [ ] 
  38.       [  make "scr-o fput :scr-x :scr-o ] ] 
  39.    [ not emptyp :scr-n ] 
  40.    output :scr-o ] 
  41.  
  42. ; *** Output list of names that contain procedures.
  43. make "allprocs [ 
  44.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  45.    make "scr-n se burylist namelist 
  46.    dowhile 
  47.    [  make "scr-x first :scr-n 
  48.       make "scr-n bf :scr-n 
  49.       if procedurep :scr-x 
  50.       [  make "scr-o fput :scr-x :scr-o ] 
  51.       [ ] ] 
  52.    [ not emptyp :scr-n ] 
  53.    output :scr-o ] 
  54.  
  55. ; *** Print out contents of directory.
  56. make "dr [
  57.    procedure [ [ ] [ :d :p ] ]
  58.    vpr ( sdir :d :p ) ]
  59.  
  60. ; *** Print out contents of directory, and all sub directories.
  61. make "dra [
  62.    procedure [ [ ] [ :d :p ] ]
  63.    vpr ( sdira :d :p ) ]
  64.  
  65. ; *** Edit the contents of specified variables.
  66. ;     This procedure works by calling the "QED" text editor by Darren M.
  67. ;     Greenwald. You may replace "QED" with the name of the text editor of
  68. ;     your choice.
  69. make "edit [
  70.    procedure [ [ :scr-n ] ]
  71.    prosave "ram:LOGO-workspace :scr-n
  72.    doscommand [ QED ram:LOGO-workspace ] 
  73.    load "ram:LOGO-workspace ] 
  74.  
  75. ; *** Close all files, windows, and screens, return to toplevel.
  76. make "end [
  77.    procedure [ ]
  78.    while [ not emptyp filelist ] [ close first filelist ]
  79.    while [ not emptyp screenlist ] [ closescreen first screenlist ]
  80.    while [ not emptyp windowlist ] [ closewindow first windowlist ]
  81.    while [ not emptyp system 6 ] [ ( system 5 first system 6 ) ]
  82.    recycle
  83.    toplevel ]
  84.  
  85. ; *** Output list of all items in one list that are not in the other.
  86. make "filter [
  87.    procedure [ [ :r :f ] [ ] [ :o ] ]
  88.    while [ not emptyp :f ]
  89.    [  if memberp first :f :r
  90.       [ ]
  91.       [  make "o fput first :f :o ]
  92.       make "f bf :f ]
  93.    output reverse :o ]
  94.  
  95. ; *** Does nothing. Ignores the output of an operation.
  96. make "ignore [ procedure [ [ :i1 ] :i2 ] ]
  97.  
  98. ; *** Set up the command window menus and demons.
  99. make "initmenu [
  100.    procedure [ ]
  101.    whenmenu [ domenu getmenu ]
  102.    setmenu @0 :com-menu ]
  103.  
  104. make "com-menu [  \ \ Utilities\ \ \ 
  105.                   [ \ Load L ]
  106.                   [ \ Save    [ \ Names N ]
  107.                               [ \ Procs P ]
  108.                               [ \ All A ] ]
  109.                   [ \ Interrupt I ]
  110.                   [ \ Top\ Level T ]
  111.                   [ \ End E ]
  112.                   [ \ Restart R ]
  113.                   [ \ Quit Q ] ]
  114.  
  115. make "domenu [
  116.    procedure [ [ :scr-menu ] [ ] [ :scr-sub ] ]
  117.    if = @0 first :scr-menu
  118.    [  if = 1 item 2 :scr-menu
  119.       [ do-com-menu :scr-menu ]
  120.       [  if and   procedurep "more-menus
  121.                   not = 0 item 2 :scr-menu
  122.          [  more-menus :scr-menu ]
  123.          [ ] ] ]
  124.    [  if procedurep "window-menus
  125.       [  window-menus :scr-menu ]
  126.       [ ] ] ]
  127.  
  128. make "do-com-menu [
  129.    procedure [ [ :scr-menu ] [ ] [ :scr-sub ] ]
  130.    make "scr-sub item 4 :scr-menu
  131.    make "scr-menu item 3 :scr-menu
  132.    cond
  133.    [  [ = 1 :scr-menu ]
  134.       [  pr [ ]
  135.          type "LOADING\ FILE:\ \  
  136.          make "scr-menu ( filerequest "Load\ File\ \ -\  )
  137.          if emptyp :scr-menu
  138.          [  pr "LOAD\ CANCELED ]
  139.          [  pr :scr-menu
  140.             load :scr-menu
  141.             pr "LOAD\ COMPLETE ]
  142.          type "? ]
  143.       [ = 2 :scr-menu ]
  144.       [  pr [ ]
  145.          type "SAVING\ FILE:\ \ 
  146.          make "scr-menu ( filerequest "Save\ File\ \ -\  )
  147.          if emptyp :scr-menu
  148.          [  pr "SAVE\ CANCELED ]
  149.          [  pr :scr-menu
  150.             cond
  151.             [  [ = 1 :scr-sub ]  [ prosave :scr-menu names ]
  152.                [ = 2 :scr-sub ]  [ prosave :scr-menu procs ]
  153.                [ = 3 :scr-sub ]  [ prosave :scr-menu all ] ]
  154.             pr "SAVE\ COMPLETE ]
  155.          type "? ]
  156.       [ = 3 :scr-menu ]  [ interrupt ]
  157.       [ = 4 :scr-menu ]  [ toplevel ]
  158.       [ = 5 :scr-menu ]  [ end ]
  159.       [ = 6 :scr-menu ]  [ restart ]
  160.       [ = 7 :scr-menu ]  [ quit ] ] ]
  161.  
  162. ; *** A LOGO command shell that may be run from within other procedures.
  163. make "interrupt [
  164.    procedure [ [ ] [ ] [ :scr-list ] ]
  165.    pr "INTERRUPT
  166.    while [ not memberp "cont :scr-list ]
  167.    [  catch "error [
  168.       while [ type "-->  make "scr-list rl  not memberp "cont :scr-list ]
  169.       [  run :scr-list ]
  170.       stop ]
  171.    poerror ] ]
  172.  
  173. ; *** Output list of all procedures needed to run the named procedure.
  174. make "link [
  175.    procedure [ [ :proc-name ] [ ] [ :link-list ] ]
  176.    if procedurep :proc-name
  177.    [  make "link-list se :proc-name [ ]
  178.       linksub bf bf thing :proc-name ]
  179.    [  ( pr :proc-name [ is not a procedure ] ) output [ ] ]
  180.    output :link-list ]
  181.  
  182. make "linksub [
  183.    procedure [ [ :proc-list ] [ ] [ :lfirst ] ]
  184.    if emptyp :proc-list [ stop ] [ ]
  185.    make "lfirst first :proc-list
  186.    cond
  187.    [  [  listp :lfirst ]   [ linksub :lfirst ]
  188.       [  procedurep :lfirst ]
  189.       [  if memberp :lfirst :link-list
  190.          [ ]
  191.          [  make "link-list fput :lfirst :link-list
  192.             linksub bf bf thing :lfirst ] ] ]
  193.    linksub bf :proc-list stop ]
  194.  
  195. ; *** convert all upper case letters to lower case.
  196. make "lower [
  197.    procedure [ [ :w ] [ ] [ :l :c :o ] ]
  198.    if listp :w
  199.    [  make "o [ ]
  200.       while [ not emptyp :w ]
  201.       [  make "o fput lower first :w :o
  202.          make "w bf :w ]
  203.       output reverse :o ]
  204.    [  make "o " 
  205.       make "c count :w
  206.       while [ >0 :c ]
  207.       [  make "l item :c :w
  208.          if  and  >= ascii :l 65  <= ascii :l 90
  209.          [  make "o fput char + ascii :l 32 :o ]
  210.          [  make "o fput :l :o ]
  211.          make "c - :c 1 ]
  212.       output :o ] ]
  213.  
  214. ; *** Output true if word fits pattern.
  215. make "matchp [
  216.    procedure [ [ :p :w ] [ ] [ :i :cp :cw :fpat :rpat ] ]
  217.    if listp :p
  218.    [  make "i false
  219.       while [ not emptyp :p ]
  220.       [  make "fpat first :p
  221.          if = "~ first :fpat
  222.          [  if matchp bf :fpat :w
  223.             [  output false ]
  224.             [ ] ]
  225.          [  make "i or :i matchp :fpat :w ]
  226.          make "p bf :p ]
  227.       output :i ]
  228.    [ ]
  229.    if = "~ first :p [ output not matchp bf :p :w ] [ ]
  230.    if memberp "* :p
  231.    [  if = first :p "*
  232.       [  while [ = first :p "* ]
  233.          [  make "p bf :p
  234.             if emptyp :p
  235.             [  output true ]
  236.             [ ] ]
  237.          if memberp "* :p
  238.          [  make "cp 1
  239.             while [ not = "* item + 1 :cp :p ] [ make "cp + 1 :cp ]
  240.             make "fpat items 1 :cp :p
  241.             make "rpat restof :cp :p
  242.             make "cw count :w
  243.             make "i 0
  244.             while [ >= :cw  + :i :cp ]
  245.             [  if = :fpat items + 1 :i :cp :w
  246.                [  output matchp :rpat restof ( + :i :cp ) :w ]
  247.                [ ]
  248.                make "i + 1 :i ]
  249.             output false ]
  250.          [  make "cp count :p
  251.             make "i count :w
  252.             output   if >= :i :cp
  253.                      [  =  :p  items ( - :i :cp -1 ) :cp :w ]
  254.                      [ false ] ] ]
  255.       [  make "i 1
  256.          while [ not = "* item + 1 :i :p ] [ make "i + 1 :i ]
  257.          output   if =  items 1 :i :p  items 1 :i :w
  258.                   [  matchp restof :i :p restof :i :w ]
  259.                   [  false ] ] ]
  260.    [ output = :p :w ] ]
  261.  
  262. ; *** Output list of unburied names that do not contain procedures.
  263. make "names [ 
  264.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  265.    make "scr-n namelist 
  266.    dowhile 
  267.    [  make "scr-x first :scr-n 
  268.       make "scr-n bf :scr-n 
  269.       if (  or primitivep :scr-x 
  270.             procedurep :scr-x 
  271.             if > 4 count :scr-x 
  272.             [  false ] 
  273.             [  = "scr- items 1 4 :scr-x ] ) 
  274.       [ ] 
  275.       [  make "scr-o fput :scr-x :scr-o ] ] 
  276.    [ not emptyp :scr-n ] 
  277.    output :scr-o ] 
  278.  
  279. ; *** Output list of all words in the list that fit the pattern.
  280. make "patfilter [
  281.    procedure [ [ :p :f ] [ ] [ :o ] ]
  282.    make "p lower :p
  283.    while [ not emptyp :f ]
  284.    [  if matchp :p lower first :f
  285.       [  make "o fput first :f :o ]
  286.       [ ]
  287.       make "f bf :f ]
  288.    output reverse :o ]
  289.  
  290. ; *** Output list of unburied names that contain procedures.
  291. make "procs [ 
  292.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  293.    make "scr-n namelist 
  294.    dowhile 
  295.    [  make "scr-x first :scr-n 
  296.       make "scr-n bf :scr-n 
  297.       if procedurep :scr-x 
  298.       [  make "scr-o fput :scr-x :scr-o ] 
  299.       [ ] ] 
  300.    [ not emptyp :scr-n ] 
  301.    output :scr-o ] 
  302.  
  303. ; *** Save names, their bindings, and their protection status to file.
  304. make "prosave [ 
  305.    procedure [ [ :scr-fn :scr-n ] [ ] [ :scr-b :scr-fp ] ] 
  306.    if listp :scr-n 
  307.    [  make "scr-b justburied :scr-n ] 
  308.    [  if buriedp :scr-n 
  309.       [  make "scr-b se :scr-n [ ] ] 
  310.       [  make "scr-b [ ] ] ] 
  311.    if emptyp :scr-b 
  312.    [  save :scr-fn :scr-n ] 
  313.    [  make "scr-fp open :scr-fn 
  314.       catch "error 
  315.       [  fprint :scr-fp [ ] 
  316.          fprint :scr-fp [ ] 
  317.          ( fshow :scr-fp "unbury :scr-b ) 
  318.          fprint :scr-fp [ ] 
  319.          fprintout :scr-fp :scr-n 
  320.          fprint :scr-fp [ ] 
  321.          ( fshow :scr-fp "bury :scr-b ) 
  322.          fprint :scr-fp [ ] ] 
  323.       close :scr-fp
  324.       saveicon :scr-fn ] ]
  325.  
  326. make "justburied [ 
  327.    procedure [ [ :scr-n ] [ ] [ :scr-x :scr-o ] ] 
  328.    dowhile 
  329.    [  make "scr-x first :scr-n 
  330.       make "scr-n bf :scr-n 
  331.       if buriedp :scr-x 
  332.       [  make "scr-o fput :scr-x :scr-o ] 
  333.       [ ] ] 
  334.    [ not emptyp :scr-n ] 
  335.    output :scr-o ] 
  336.  
  337. ; *** Closes windows, screens, and files, erases all but utility-stuff.
  338. make "restart [
  339.    procedure [ ]
  340.    setmenu @0 [ ]
  341.    whenclose [ ]
  342.    whenmenu [ ]
  343.    whenmouse [ ]
  344.    whenchar [ ]
  345.    if buriedp "utility-stuff
  346.    [  erase filter :utility-stuff all
  347.       initmenu
  348.       end ]
  349.    [  erase namelist
  350.       erase burylist
  351.       recycle
  352.       toplevel ] ]
  353.  
  354. ; *** Reverse the order of the items in the object.
  355. make "reverse [ 
  356.    procedure [ [ :from ] [ :into ] ]
  357.    if emptyp :into
  358.    [  if wordp :from
  359.       [  make "into "  ] [ ] ] [ ]
  360.    if emptyp :from
  361.    [  output :into ]
  362.    [  output  ( reverse  bf :from  fput first :from :into ) ] ]
  363.  
  364. ; *** Output sorted directory list.
  365. make "sdir [
  366.    procedure [ [ ] [ :d :p ] [ :c :t :dn :fn ] ]
  367.    if emptyp :d [ make "c dir ] [ make "c ( dir :d ) ]
  368.    if emptyp :p [ ] [ make "c patfilter :p :c ]
  369.    while [ not emptyp :c ] [
  370.       make "t first :c
  371.       make "c bf :c
  372.       if = "/ last :t
  373.          [ make "dn fput :t :dn ] 
  374.          [ make "fn fput :t :fn ] ]
  375.    output
  376.       se if > count :dn 1 [ sort "alphap :dn ] [ :dn ]
  377.          if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]
  378.  
  379. ; *** Output sorted directory list.
  380. make "sdira [
  381.    procedure [ [ ] [ :d :p ] [ :c :t :dn :fn :w ] ]
  382.    if emptyp :d
  383.       [ make "c dir make "d "  ]
  384.       [  make "c ( dir :d )
  385.          if or = "/ last :d = ": last :d
  386.             [  ]
  387.             [  make "d word :d "/ ] ]
  388.    if emptyp :p [ ] [ make "c patfilter :p :c ]
  389.    while [ not emptyp :c ] [
  390.       make "t first :c
  391.       make "c bf :c
  392.       if = "/ last :t
  393.          [ make "dn fput :t :dn ] 
  394.          [ make "fn fput :t :fn ] ]
  395.    make "dn if > count :dn 1 [ sort [ not alphap ] :dn ] [ :dn ]
  396.    while [ not emptyp :dn ] [
  397.       make "t first :dn
  398.       make "dn bf :dn
  399.       make "c fput ( sdira word :d :t ) :c
  400.       make "c fput :t :c ] 
  401.    output se :c if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]
  402.  
  403. ; *** Sort list according to test. Where "test" is the compare operation.
  404. make "sort [
  405.    procedure [ [ :comparep :ra ] [ ] [ :n :l :j :ir :i :rra ] ]
  406.    make "comparep ( se  [ procedure [ [ :a :b ] ] output ]
  407.                         :comparep
  408.                         [ :a :b ] )
  409.    make "n count :ra
  410.    make "ra se :ra [ ]
  411.    make "l + 1 int / :n 2
  412.    make "ir :n
  413.    while [ true ]
  414.    [  if > :l 1
  415.       [  make "l - :l 1
  416.          make "rra item :l :ra ]
  417.       [  make "rra item :ir :ra
  418.          repitem :ir :ra item 1 :ra
  419.          make "ir - :ir 1
  420.          if = :ir 1 
  421.          [  output fput :rra bf :ra ] [ ] ]
  422.       make "i :l
  423.       make "j * 2 :l
  424.       while [ >= :ir :j ]
  425.       [  if if    < :j :ir
  426.             [ comparep item :j :ra item + 1 :j :ra ]
  427.             [ false ]
  428.          [  make "j + 1 :j ] [ ]
  429.          if comparep :rra item :j :ra
  430.          [  repitem :i :ra item :j :ra
  431.             make "i :j
  432.             make "j + :i :j ]
  433.          [  make "j + 1 :ir ] ]
  434.       repitem :i :ra :rra ] ]
  435.  
  436. ; *** Prepare screen, window, and turtle for simple turtle graphics.
  437. make "turtle [
  438.    procedure [ [ ] [ :v :d ] ]
  439.    if numberp :d [ ] [ make "d 1 ]
  440.    if numberp :v [ ] [ make "v 3 ]
  441.    ( intuition 6 @0 )
  442.    recycle
  443.    make "s1 ( openscreen :v :d [ turtle ] )
  444.    make "w1 openwindow :s1
  445.    make "t1 openturtle :w1
  446.    setrgb :s1 0 [ 0  0  0 ]
  447.    setrgb :s1 1 [ 14 14 14 ]
  448.    ( intuition 2 @0 0 0 )
  449.    ( intuition 8 @0 550 54 )
  450.    if < 300 peek -2 psum peek 0 :s1 14
  451.    [  ( intuition 1 @0 0 350 ) ]
  452.    [  ( intuition 1 @0 0 150 ) ]
  453.    ( intuition 6 @0 ) ]
  454.  
  455. ; *** Print out contents of lists verticaly.
  456. make "vpr [
  457.    procedure [ [ :l ] [ :i ] ]
  458.    if emptyp :i [ make "i 0 ] [ ]
  459.    if listp :l
  460.    [  while [ not emptyp :l ]
  461.       [  ( vpr first :l + 1 :i )
  462.          make "l bf :l ]
  463.       pr [ ] ]
  464.    [  repeat :i [ type "\  ] 
  465.       pr :l ] ]
  466.  
  467. ; *** A list of names defined in this file.
  468. make "utility-stuff [  e pi dr dra sdir sdira edit prosave allnames names
  469.    allprocs procs justburied all link linksub ignore
  470.    patfilter lower matchp
  471.    end reverse filter initmenu domenu do-com-menu interrupt restart
  472.    sort vpr com-menu turtle utility-stuff ] 
  473.  
  474. ; *** Bury the names defined in this file.
  475. bury :utility-stuff
  476.  
  477. ; *** Initialize the command window menus and menu demon.
  478. initmenu
  479.  
  480.